home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / Widget / Witems.stklos < prev    next >
Encoding:
Text File  |  1995-09-13  |  10.8 KB  |  258 lines
  1. ;;;;
  2. ;;;; STk adaptation of the Tk widget demo.
  3. ;;;;
  4. ;;;; This demonstration script creates a canvas that displays the
  5. ;;;; canvas item types.
  6. ;;;;
  7.  
  8. (define (demo-items)
  9.   ;;
  10.   ;; Functions used by this demo
  11.   ;;
  12.   (let* ((w    (make-demo-toplevel  "items"
  13.                     "Canvas Item Demonstration"
  14.                     "This window contains a canvas widget with examples of the various kinds of items supported by canvases.  The following operations are supported:\n  Button-1 drag:\tmoves item under pointer.\n  Button-2 drag:\trepositions view.\n  Button-3 drag:\tstrokes out area.\n  Ctrl+f:\t\tprints items under area."))
  15.      (c    (make <Scroll-Canvas>
  16.              :parent       w
  17.              :scroll-region (list 0 0 '30c '24c) 
  18.              :width         "15c" 
  19.              :height        "10c"
  20.              :relief       "groove"
  21.              :border-width 3
  22.              :h-scroll-side "bottom"))
  23.      (font1  "-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*")
  24.      (font2  "-Adobe-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*")
  25.      (mono   (= (winfo 'depth c) 1))
  26.      (blue   (if mono "black" "DeepSkyBlue3"))
  27.      (red    (if mono "black" "red"))
  28.      (bisque (if mono "black" "bisque3"))
  29.      (green  (if mono "black" "SeaGreen3")))
  30.     
  31.       (pack c :expand #t :fill "both")
  32.       
  33.       ;; Display a 3x3 rectangular grid.
  34.       (make <Rectangle> :parent c :coords '(0c 0c 30c 24c)  :width 2)
  35.       (make <Line>      :parent c :coords '(0c 8c 30c 8c)   :width 2)
  36.       (make <Line>      :parent c :coords '(0c 16c 30c 16c) :width 2)
  37.       (make <Line>      :parent c :coords '(10c 0c 10c 24c) :width 2)
  38.       (make <Line>      :parent c :coords '(20c 0c 20c 24c) :width 2)
  39.  
  40.       ;;
  41.       ;; Set up demos within each of the areas of the grid.
  42.       ;;
  43.  
  44.       ;; Lines
  45.       (make <Text-item> :parent c :coords '(5c .2c) :text "Lines" :anchor "n")
  46.       (make <Line> :parent c :coords '(1c 1c 3c 1c 1c 4c 3c 4c) :width "2m" 
  47.         :fill blue :cap "butt" :join "miter" :tags "item")
  48.       (make <Line> :parent c :coords '(4.67c 1c 4.67c 4c) :arrow "last" 
  49.         :tags "item")
  50.       (make <Line> :parent c :coords '(6.33c 1c 6.33c 4c) :arrow "both" 
  51.         :tags "item")
  52.       (make <Line> :parent c 
  53.         :coords '(5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c 8.4c 4.4c) 
  54.         :width 3 :fill red :tags "item")
  55.       (make <Line> :parent c :coords '(1c 5c 7c 5c 7c 7c 9c 7c) :width '.5c 
  56.         :stipple (string-append "@" *STk-images* "grey.25")
  57.         :arrow "both" :arrow-shape (list 15 15 7) :tags "item")
  58.       (make <Line> :parent c 
  59.         :coords '(1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c) :width '.5c
  60.         :cap-style "round" :join-style "round" :tags "item")
  61.  
  62.       ;; Smoothed lines
  63.        (make <Text-item> :parent c :coords '(15c .2c) 
  64.          :text "Curves (smoothed lines)" :anchor "n")
  65.        (make <Line> :parent c :coords '(11c 4c 11.5c 1c 13.5c 1c 14c 4c)
  66.          :smooth #t :fill blue :tags "item")
  67.        (make <Line> :parent c :coords '(15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c)
  68.          :smooth #t :arrow "both" :width 3 :tags "item")
  69.        (make <Line> :parent c 
  70.          :coords '(12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c 16.5c 4.5c 13.5c 7.5c 12c 6c)
  71.          :smooth #t :width '3m :cap-style "round"
  72.          :stipple (string-append "@" *STk-images* "grey.25")
  73.          :fill red :tags "item")
  74.  
  75.        ;; Polygons
  76.        (make <Text-item> :parent c :coords '(25c .2c) :text "Polygons"
  77.          :anchor "n")
  78.        (make <Polygon> :parent c 
  79.          :coords '(21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c 24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c)
  80.          :fill green :outline "black" :width 4 :tags "item")
  81.        (make <Polygon> :parent c 
  82.          :coords '(25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c 29c 1c 29c 4c 29c 4c)
  83.          :fill red :smooth #t :tags "item")
  84.        (make <Polygon> :parent c 
  85.          :coords '(22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c)
  86.          :stipple (string-append "@" *STk-images* "grey.25")
  87.          :outline "black" :tags "item")
  88.  
  89.        ;; Rectangles
  90.        (make <Text-item> :parent c :coords '(5c 8.2c) :text "Rectangles" 
  91.          :anchor "n")
  92.        (make <Rectangle> :parent c :coords '(1c 9.5c 4c 12.5c)
  93.          :outline red :width '3m :tags "item")
  94.        (make <Rectangle> :parent c :coords '(0.5c 13.5c 4.5c 15.5c)
  95.          :fill green :tags "item")
  96.        (make <Rectangle> :parent c :coords '(6c 10c 9c 15c)
  97.          :stipple (string-append "@" *STk-images* "grey.25")
  98.          :outline "" :fill blue :tags "item")
  99.  
  100.        ;; Ovals
  101.        (make <Text-item> :parent c :coords '(15c 8.2c) :text "Ovals" :anchor "n")
  102.        (make <Oval> :parent c :coords '(11c 9.5c 14c 12.5c)
  103.          :outline red :width '3m :tags "item")
  104.        (make <Oval> :parent c :coords '(10.5c 13.5c 14.5c 15.5c)
  105.          :fill green :tags "item")
  106.        (make <Oval> :parent c :coords '(16c 10c 19c 15c)
  107.          :stipple (string-append "@" *STk-images* "grey.25")
  108.          :outline "" :fill blue :tags "item")
  109.  
  110.        ;; Texts
  111.        (make <Text-item> :parent c :coords '(25c 8.2c) :text "Text" :anchor "n")
  112.        (make <Rectangle> :parent c :coords '(22.4c 8.9c 22.6c 9.1c))
  113.        (make <Text-item> :parent c :coords '(22.5c 9c) :anchor "n"
  114.          :font font1 :width '4c 
  115.          :text "A short string of text, word-wrapped, justified left, and anchored north (at the top).  The rectangles show the anchor points for each piece of text." 
  116.          :tags "item")
  117.        (make <Rectangle> :parent c :coords '(25.4c 10.9c 25.6c 11.1c))
  118.        (make <Text-item> :parent c :coords '(25.5c 11c) :anchor "w" 
  119.          :font font1 :fill blue
  120.          :text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." 
  121.          :justify "center" :tags "item")
  122.        (make <Rectangle> :parent c :coords '(24.9c 13.9c 25.1c 14.1c))
  123.        (make <Text-item> :parent c :coords '(25c 14c)
  124.          :font font2 :anchor "c" :fill red
  125.          :stipple (string-append "@" *STk-images* "grey.5")
  126.          :text "Stippled characters" :tags "item")
  127.  
  128.        ;; Arcs
  129.        (make <Text-item> :parent c :coords '(5c 16.2c) :text "Arcs" :anchor "n")
  130.        (make <Arc> :parent c :coords '(0.5c 17c 7c 20c) :fill green 
  131.          :outline "black" :start 45 :extent 270 :style "pieslice" :tags "item")
  132.        (make <Arc> :parent c :coords '(6.5c 17c 9.5c 20c) :width '4m :style "arc"
  133.          :outline blue :start -135 :extent 270
  134.          :outline-stipple (string-append "@" *STk-images* "grey.25")
  135.          :tags "item")
  136.        (make <Arc> :parent c :coords '(0.5c 20c 9.5c 24c) :width '4m 
  137.          :style "pieslice" :fill "" :outline red :start 225 :extent -90 
  138.          :tags "item")
  139.        (make <Arc> :parent c :coords '(5.5c 20.5c 9.5c 23.5c) :width '4m 
  140.          :style "chord" :fill blue :outline "" :start 45 :extent 270 
  141.          :tags "item")
  142.        
  143.        ;; Bitmaps
  144.        (make <Text-item> :parent c :coords '(15c 16.2c) :text "Bitmaps" :anchor "n")
  145.  
  146.        (make <Bitmap-item> :parent c :coords '(13c 20c)
  147.          :bitmap-name (string-append "@" *STk-images* "face")
  148.          :tags "item")
  149.        (make <Bitmap-item> :parent c :coords '(17c 18.5c)
  150.          :bitmap-name (string-append "@" *STk-images* "noletters")
  151.          :tags "item")
  152.        (make <Bitmap-item> :parent c :coords '(17c 21.5c)
  153.          :bitmap-name (string-append "@" *STk-images* "letters")
  154.          :tags "item")
  155.        
  156.        ;; Windows
  157.        (make <Text-item> :parent c :coords '(25c 16.2c) :text "Windows" :anchor "n")
  158.        (make <Canvas-window> :parent c :coords '(21c 18c) :anchor "nw"
  159.          :window (make <Button> :text "Press Me" :parent c
  160.                :command (lambda () 
  161.                       (let ((i (make <Text-item> :parent c 
  162.                              :coords '(25c 18.1c) 
  163.                              :anchor "n" 
  164.                              :text "Ouch!!" 
  165.                              :fill "Red")))
  166.                     (after 500 (lambda ()
  167.                              (destroy i))))))
  168.          :tags "item")
  169.        (make <Canvas-window> :parent c :coords '(21c 21c) :anchor "nw"
  170.          :window (make <Entry>  :parent c :width 20 :relief "sunken"
  171.                :value "Edit thid text")
  172.          :tags "item")
  173.       
  174.        (make <Canvas-window> :parent c :coords '(28.5c 17.5c) :anchor "n" 
  175.          :window (make <Scale> :parent c :from 0 :to 100 :length '6c 
  176.                :slider-length '.4c :width '.5c :tick-interval 0)
  177.          :tags "item")
  178.        (make <Text-item> :parent c :coords '(21c 17.9c) :text "Button" :anchor "sw")
  179.        (make <Text-item> :parent c :coords '(21c 20.9c) :text "Entry"  :anchor "sw")
  180.        (make <Text-item> :parent c :coords '(28.5c 17.4c) :text "Scale" :anchor "s")
  181.  
  182.        ;; Set up event bindings for canvas:
  183.        (let ((action #f)
  184.          (x0 0) (y0 0)
  185.          (x1 0) (y1 0)
  186.          (x2 0) (y2 0))
  187.  
  188.      (define (item-enter c)
  189.        (let ((item (car (find-items c 'with "current"))))
  190.          (cond
  191.           ((= (winfo 'depth c) 1)  
  192.                    (set! action #f))
  193.           ((is-a? item <Canvas-window>)  
  194.             (set! action #f))
  195.           ((is-a? item <Bitmap-item>)
  196.                    (let ((bg (slot-ref item 'background)))
  197.               (set! action `(slot-set! ,item 'background ,bg))
  198.               (slot-set! item 'background "SteelBlue2")))
  199.           ((and (or (is-a? item <Rectangle>)
  200.             (is-a? item <Oval>)
  201.             (is-a? item <Arc>))
  202.             (equal? (slot-ref item 'fill) ""))
  203.                    (let ((outline (slot-ref item 'outline)))
  204.               (set! action `(slot-set! ,item 'outline ,outline))
  205.               (slot-set! item 'outline "SteelBlue2")))
  206.           (ELSE    (let ((fill (slot-ref item 'fill)))
  207.               (set! action `(slot-set! ,item 'fill ,fill))
  208.               (slot-set! item 'fill "SteelBlue2"))))))
  209.  
  210.      ;; Utility procedures for stroking out a rectangle and printing what's
  211.      ;; underneath the rectangle's area.
  212.      
  213.      (define (item-mark c x y)
  214.        (set! x1 (canvas-x c x))
  215.        (set! y1 (canvas-y c y))
  216.        (canvas-delete c "area"))
  217.  
  218.      (define (item-stroke c x y)
  219.        (let ((x (canvas-x c x))
  220.          (y (canvas-y c y)))
  221.          (unless (and (= x x1) (= y y1))
  222.            (canvas-delete c "area")
  223.            (make <Rectangle> :parent c :coords (list x1 y1 x y) :tags "area")
  224.            (set! x2 x)
  225.            (set! y2 y))))
  226.  
  227.      (define (items-under-area c)
  228.        (format #t "Items enclosed by area: ~S\n" 
  229.            (find-items c 'enclosed x1 y1 x2 y2))
  230.        (format #t "Items overlapping area: ~S\n"
  231.            (cdr (reverse (find-items c 'overlapping x1 y1 x2 y2)))))
  232.  
  233.      ;; Utility procedures to support dragging of items.
  234.      (define (item-start-drag c x y)
  235.        (set! x0 (canvas-x c x))
  236.        (set! y0 (canvas-x c y)))
  237.      
  238.      (define (item-drag c x y)
  239.        (let ((x (canvas-x c x))
  240.          (y (canvas-x c y)))
  241.          (move c "current" (- x x0) (- y y0))
  242.          (set! x0 x)
  243.          (set! y0 y)))
  244.  
  245.        (bind c "item" "<Any-Enter>" (lambda () (item-enter c)))
  246.        (bind c "item" "<Any-Leave>" (lambda () (eval action)))
  247.  
  248.        (bind c "<1>"             (lambda (x y) (item-start-drag c x y)))
  249.        (bind c "<B1-Motion>"         (lambda (x y) (item-drag c x y)))
  250.        (bind c "<2>"             (lambda (x y) (scan c 'mark x y)))
  251.        (bind c "<B2-Motion>"        (lambda (x y) (scan c 'dragto x y)))
  252.        (bind c "<3>"                 (lambda (x y) (item-mark c x y)))
  253.        (bind c "<B3-Motion>"         (lambda (x y) (item-stroke c x y)))
  254.        (bind c "<Control-f>"        (lambda () (items-under-area c))))
  255.        (focus c)
  256.        
  257. ))
  258.